Language/OS - Multiplatform Resource Library

home *** CD-ROM | disk | FTP | other *** search

/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / scheme / pcscheme / geneva / sources.exe / SOURCES / ASM / STACK.ASM < prev next >

Wrap

Assembly Source File | 1993-10-14 | 54.0 KB | 1,687 lines

;* STACK.ASM ;************************************************************************ ;* * ;* PC Scheme/Geneva 4.00 Borland TASM code * ;* * ;* (c) 1985-1988 by Texas Instruments, Inc. See COPYRIGHT.TXT * ;* (c) 1992 by L. Bartholdi & M. Vuilleumier, University of Geneva * ;* * ;*----------------------------------------------------------------------* ;* * ;* All that concern the stack (push, pop, execute, return) * ;* (interpreter support) * ;* * ;*----------------------------------------------------------------------* ;* * ;* Created by: John Jensen Date: 1985 * ;* Revision history: * ;* - 18 Jun 92: Renaissance (Borland Compilers, ...) * ;* * ;* ``In nomine omnipotentii dei'' * ;************************************************************************ IDEAL %PAGESIZE 60, 132 MODEL small LOCALS @@ INCLUDE "scheme.ash" INCLUDE "interprt.ash" DATASEG stk_in DD 0 ; number of bytes moved into the stack stk_out DD 0 ; number of bytes moved out of the stack CODESEG ;************************************************************************ ;* al * ;* Push register onto stack PUSH reg * ;* * ;* Purpose: Interpreter support to cause the contents of one of the * ;* VM's general registers to be pushed onto the VM's * ;* runtime stack * ;************************************************************************ PROC spush get1op @@retry: mov di, [topofstack] cmp di, STKSIZE-SIZE POINTER; test for overflow jge @@overflow add di, SIZE POINTER ; decrement stack top pointer mov [topofstack], di mov bx, ax ; copy register number mov ax, [regs+bx.page] mov [(POINTER s_stack+di).page], al mov ax, [regs+bx.disp] mov [(POINTER s_stack+di).disp], ax jmp next @@overflow: ; process stack overflow-- copy contents to heap push ax ; preserve "important" regs across call call stk_ovfl C ; handle overflow situation pop ax mov bx, [cb_reg.page] ldpage es, bx jmp @@retry ENDP spush ;************************************************************************ ;* al * ;* Pop register from stack POP reg * ;* * ;* Purpose: Interpreter support to cause the contents of one of the * ;* VM's general registers to be replaced by popping the * ;* value off the top of the VM's runtime stack * ;* * ;* Note: There's no need to check for stack underflow on a simple * ;* POP, because the stack is broken into segments only at stack * ;* frame boundaries. Underflow can occur only when stack space * ;* for a stack frame is released (i.e., during an EXIT). * ;************************************************************************ PROC spop get1op mov di, [topofstack] mov bx, ax ; copy register number mov al, [(POINTER s_stack+di).page] mov [regs+bx.page], ax mov ax, [(POINTER s_stack+di).disp] mov [regs+bx.disp], ax sub di, SIZE POINTER ; decrement topofstack pointer mov [topofstack], di jmp next ENDP spop ;************************************************************************ ;* al * ;* Drop-- remove top elements from stack DROP n * ;* * ;* Purpose: Interpreter support to cause the top "n" elements of the * ;* VM's runtime stack to be discarded. "n" is determined * ;* from the operand of the DROP instruction * ;* * ;* Note: There's no need to check for stack underflow on a DROP * ;* because the stack is broken into segments only at stack * ;* frame boundaries. Underflow can occur only when stack space * ;* for a stack frame is released (i.e., during an EXIT). * ;************************************************************************ PROC sdrop get1op mov dx, ax ; multiply by 3 (size of element) shl ax, 1 add ax, dx sub [topofstack], ax jmp next ENDP sdrop ;************************************************************************ ;* al ah * ;* Local from local stack frame LDLOCAL dest, entry * ;************************************************************************ PROC ld_local get2op mov bl, al ; copy destination register number mov di, bx ; into di (clear high order BYTE) mov bl, ah ; copy the entry number (clear high BYTE) mov ax, bx ; bx <- entry * 3 sal ax, 1 add bx, ax add bx, [frameptr] ; bx <- frameptr + (entry * 3) mov al, [s_stack+bx.data.page] mov [regs+di.bpage], al mov ax, [s_stack+bx.data.disp] mov [regs+di.disp], ax jmp next ENDP ld_local ;************************************************************************ ;* al ah * ;* Store into local stack frame STLOCAL src, entry * ;************************************************************************ PROC st_local get2op mov bl, al ; copy destination register number mov di, bx ; into di (clear high order BYTE) mov bl, ah ; copy the entry number (clear high BYTE) mov ax, bx ; bx <- entry * 3 sal ax, 1 add bx, ax add bx, [frameptr] ; bx <- frameptr + (entry * 3) mov al, [regs+di.bpage] mov dx, [regs+di.disp] mov [s_stack+bx.data.page], al mov [s_stack+bx.data.disp], dx jmp next ENDP st_local ;************************************************************************ ;* al al ah * ;* Load from higher lexical level LDLEX dest, entry, lvl * ;************************************************************************ PROC ld_lex get1op push ax get2op save <si> ; save current location pointer mov bl, ah ; clear high order BYTE of the lexical mov cx, bx ; level number delta and move to cx mov bl, al ; align, and save entry number push bx call delta_lv ; get pointer to parent's stack frame pop ax ; get entry number mov bx, ax ; bx <- entry number * 3 shl ax, 1 add bx, ax pop di ; get destination register number mov al, [(STKFDEF es:si+bx).data.page] mov bx, [(STKFDEF es:si+bx).data.disp] mov [regs+di.bpage], al mov [regs+di.disp], bx jmp next_pc ENDP ld_lex ;************************************************************************ ;* al al ah * ;* Store into higher lexical level STLEX src, entry, lvl * ;************************************************************************ PROC st_lex get1op push ax get2op save <si> mov bl, ah mov cx, bx mov bl, al ; align, and save entry number push bx call delta_lv ; get pointer to parent's stack frame pop ax ; get entry number mov bx, ax ; bx <- entry number * 3 shl ax, 1 add bx, ax pop di ; get source register number mov al, [regs+di.bpage] mov dx, [regs+di.disp] mov [(STKFDEF es:si+bx).data.page], al mov [(STKFDEF es:si+bx).data.disp], dx jmp next_pc ENDP st_lex ;************************************************************************ ;* ax al ah * ;* Call local routine CALL lbl,delta-lvl,delta-heap* ;************************************************************************ PROC call_lcl lea ax, [cs:next_pc] ; For a "CALL", make a tail push ax ; recursive call to following routine ; jmp call_local ; fall thru ENDP call_lcl PROC call_local lods [WORD es:si] mov dx, ax lods [WORD es:si] inc al ; increment releative lexical level mov bl, al ; isolate delta-lvl and save it push bx mov bl, ah ; isolate delta-heap and save it, too push bx add dx, si ; compute branch destination address mov [save_si], dx ; store updated location counter call new_sf ; allocate new stack frame on top of stack mov si, bx ; save pointer to new stack frame pop cx ; restore the delta-heap argument call delta_hp ; determine new heap env pointer mov [s_stack+si.heap.page], bl mov [s_stack+si.heap.disp], di pop cx ; restore the delta-lvl argument push si ; save new stack frame pointer call delta_lv ; get static link pop si ; retrieve new stack frame pointer mov [s_stack+si.statlink.disp], bx mov [frameptr], si ret ENDP call_local ;************************************************************************ ;* ax al ah * ;* Call local routine tail recursively CALL-TR lbl,delta-lvl,delta-heap* ;************************************************************************ PROC call_ltr lea ax, [cs:next_pc] ; For a "CALL-TR", make a tail push ax ; recursive call to following routine ; jmp call_local_tr ; fall thru ENDP call_ltr PROC call_local_tr lods [WORD es:si] mov dx, ax lods [WORD es:si] inc al ; increment releative lexical level mov bl, al ; isolate delta-lvl and save it push bx mov bl, ah ; isolate delta-heap and save it, too mov cx, bx add dx, si ; compute branch destination address mov [save_si], dx ; store updated location counter mov ax, [frameptr] mov si, ax add ax, SIZE STKFDEF-SIZE POINTER mov [topofstack], ax ; drop any local var's off top of stack call delta_hp ; determine new heap env pointer mov [s_stack+si.heap.page], bl mov [s_stack+si.heap.disp], di mov [s_stack+si.closure.page], NIL_PAGE*2 mov [s_stack+si.closure.disp], NIL_DISP pop cx ; restore the delta-lvl argument push si ; save pointer to stack frame call delta_lv ; get static link pop si mov [s_stack+si.statlink.disp], bx ret ENDP call_local_tr ;************************************************************************ ;* al ah * ;* Call closed procedure CALL-CLOSURE ftn, #args * ;* * ;* Purpose: Scheme interpreter support for procedure calls to fully * ;* closed functions * ;************************************************************************ PROC call_clo lea ax, [cs:next_pc] ; For a "CALL-CLOSURE" make a tail push ax ; recursive call to the following routine get2op ; jmp call_closure ; fall thru ENDP call_clo PROC call_closure mov bl, ah ; isolate the number of arguments passed push bx mov bl, al ; copy the procedure object register mov di, [regs+bx.page] ; load page number of closure pointer cmp [ptype+di], CLOSTYPE je @@regular jmp call_continuation @@regular: push bx ; save number of procedure pointer reg call new_sf ; allocate a new stack frame pop si call_non_tr: ; Load the pointer to the closure object from the operand register push si ; save number of register containing closure mov di, [regs+si.page] mov si, [regs+si.disp] ldpage es, di mov ax, di ; Put the closure pointer into the newly allocated stack frame mov [s_stack+bx.closure.page], al mov [s_stack+bx.closure.disp], si mov al, [(CLOSDEF es:si).heap.page] mov dx, [(CLOSDEF es:si).heap.disp] mov [s_stack+bx.heap.page], al mov [s_stack+bx.heap.disp], dx mov [s_stack+bx.statlink.disp], 0 mov [frameptr], bx ; Obtain the entry point address from the closure object mov ax, [(CLOSDEF es:si).codeblk.disp] mov [cb_reg.disp], ax add ax, [(CLOSDEF es:si).entry.val] mov [save_si], ax ; and set up for load into location pointer xor ax, ax mov al, [(CLOSDEF es:si).codeblk.page] mov [cb_reg.bpage], al ; Determine if the closed function is a mulambda pop di cx ; get closure, # args passed mov ax, [(CLOSDEF es:si).args.val] or ax, ax jl @@mulambda cmp ax, cx ; verify args passed/expected agree je @@ret @@wrongargs: lea di, [regs+di] push es ; save es over C call call wrong_args C, cx, di ; print error message and fixup VM regs pop es restore <si> pop ax ; drop the (fake) return address jmp sch_err @@ret: ret @@mulambda: push di ; we nee regs purty bad. save the source pointer mov si, cx ; compute the address of the last shl si, 1 ; register which contains an argument shl si, 1 ; to be passed to the mulambda lea si, [regs+si] cmp cx, NUM_REGS - 2 ; is tail in R62 ? jae @@manyargs lea di, [si+SIZE REG] ; di is first free reg mov [(REG di).disp], NIL_DISP ; if not, nil-terminate the arglist mov [(REG di).page], NIL_PAGE jmp @@taildone @@manyargs: mov di, si ; in this case, just take the last one sub si, SIZE REGS ; as tail dec ax ; one less cons to perform @@taildone: mov dx, cx ; save number of arguments passed add cx, ax ; adjust number of arguments passed inc cx ; by number required jg @@loop je @@muret mov cx, dx ; restore count of args passed pop di ; restore the source reg for error handling jmp @@wrongargs @@loop: push es cx ; save cx,es over C call call cons C, si, si, di ; cons together ptrs in regs "n" and "n+1" pop cx es mov [(REG di).page], UN_PAGE*2 mov [(REG di).disp], UN_DISP mov di, si ; update pointers for next iteration sub si, SIZE REG loop @@loop ; repeat for all arguments passed @@muret: pop di ; trash the source reg ret call_continuation: ; Function call is invoking a continuation-- unless we've got an error cmp [ptype+di], CONTTYPE je @@contok add bx, OFFSET regs pop ax ; drop the # of arguments push es ; save es over C call call not_procedural C, bx, ax pop es restore <si> pop ax ; drop the (fake) return address jmp sch_err ; Oh, wow! we've got a continuation to invoke ; ; Note: the contents of the stack is restored by making the VM's ; previous stack segment register point to the continuation ; object and signaling an underflow condition. This restores ; the stack, base, topofstack, PREV_page, and PREV_disp. The ; remainder of this code fetches the values of CB_page, ; CB_disp, frameptr, and LP from the continuation object. @@contok: push bx ; save pointer to continuation object mov al, [regs+bx.bpage] ; copy continuation pointer into prev_reg mov dx, [regs+bx.disp] mov [prev_reg.bpage], al mov [prev_reg.disp], dx call stk_unfl C pop di ; retrieve ptr to reg with continuation ptr. mov bx, [regs+di.page] ; make es:[si] point to the continuation ldpage es, bx mov si, [regs+di.disp] xor bx, bx mov bl, [(CONTDEF es:si).codeblk.page] mov ax, [(CONTDEF es:si).codeblk.disp] mov [cb_reg.bpage], bl mov [cb_reg.disp], ax add ax, [(CONTDEF es:si).retaddr.val] ; restore return address displacement mov [save_si], ax mov ax, [(CONTDEF es:si).dynlink.val] ; restore frameptr from dynamic link sub ax, [base] ; adjust for current stack buffer base mov [frameptr], ax mov al, [(CONTDEF es:si).fluid.page] ; restore fluid environment (FNV_reg) mov dx, [(CONTDEF es:si).fluid.disp] mov [fnv_reg.bpage], al mov [fnv_reg.disp], dx mov al, [(CONTDEF es:si).globenv.page] ; restore global environment (GNV_reg) mov dx, [(CONTDEF es:si).globenv.disp] mov [gnv_reg.bpage], al mov [gnv_reg.disp], dx pop ax ; get number of arguments passed cmp ax, 1 ; one argument passed? jne @@conterror ret @@conterror: add di, OFFSET regs ; load address of continuation's register push es ; save es over C call call wrong_args C, ax, di ; print error message and fixup VM regs pop es restore <si> pop ax ; drop (fake) return address jmp sch_err ENDP call_closure ;************************************************************************ ;* al ah * ;* Call closed proc tail recursively CALL-CLOSURE-TR ftn, #args * ;* * ;* Purpose: Scheme interpreter support for procedure calls to fully * ;* closed functions tail recursively * ;************************************************************************ PROC call_ctr lea ax, [cs:next_pc] ; For "CALL-CLOSURE-TR" make tail push ax ; recursive call to the following routine get2op ; jmp call_closed_tr ; fall thru ENDP call_ctr PROC call_closed_tr mov bl, ah ; isolate the number of arguments push bx mov bl, al ; copy the procedure object register mov di, [regs+bx.page] ; load page number of procedure object cmp [ptype+di], CLOSTYPE je @@regular jmp call_continuation @@regular: mov si, bx ; copy reg number with closure pointer mov ax, [frameptr] ; use current stack frame for this call mov bx, ax ; drop any local vars from top of stack add ax, SIZE STKFDEF-SIZE POINTER mov [topofstack], ax jmp call_non_tr ENDP call_closed_tr ;************************************************************************ ;* Call/cc local CALL/CC lbl,delta-lvl,delta-heap* ;* * ;* Purpose: Interpreter support for a local call with current * ;* continuation * ;* * ;* Description: * ;* 1. The local CALL support is called to create a new * ;* stack frame and to establish the VM's registers * ;* for the branch to the called routine. * ;* 2. A stack overflow condition is signaled to cause * ;* the contents of the stack to be saved on the heap * ;* in a continuation object format. * ;* 3. Fields in the continuation object are updated to * ;* cause control to return to the correct place when * ;* the continuation is invoked. * ;* 4. Control returns to the Scheme interpreter. * ;************************************************************************ PROC call_cc call call_local ; call CALL's alternate entry point in_call_cc: call stk_ovfl C ; signal stack overflow mov bx, [prev_reg.page] ; move pointer to continuation into R1 mov di, [prev_reg.disp] mov [reg1.page], bx mov [reg1.disp], di ldpage es, bx mov si, [frameptr] ; create a pointer to the current stack add si, OFFSET s_stack ; frame (the new one) mov al, [(STKFDEF si).codeblk.page] ; copy the value of the VM's code base mov dx, [(STKFDEF si).codeblk.disp] mov [(CONTDEF es:di).codeblk.page], al ; into the continuation object mov [(CONTDEF es:di).codeblk.disp], dx mov ax, [(STKFDEF si).retaddr.disp] mov [(CONTDEF es:di).retaddr.val], ax mov ax, [(STKFDEF si).dynlink.disp] mov [(CONTDEF es:di).dynlink.val], ax jmp next_pc ENDP call_cc ;************************************************************************ ;* Call/cc tail recursively CALL/CC-TR lbl,delta-lvl,delta-heap* ;* * ;* Purpose: Interpreter support for a tail recursive local call with* ;* current continuation * ;* * ;* Description: * ;* 1. The local CALL-TR support is called to update the * ;* current stack frame and to establish the VM's * ;* registers for the branch to the called routine. * ;* 2. Control transfers to the CALL/CC support to create * ;* the continuation object. * ;************************************************************************ PROC cl_cctr call call_local_tr jmp in_call_cc ENDP cl_cctr ;************************************************************************ ;* al * ;* Call/cc with of procedure object CALL/CC-CLOSURE ftn * ;* * ;* Purpose: Interpreter support for a call with current continuation* ;* of a fully closed function * ;************************************************************************ PROC clcc_c get1op mov ah, 1 ; indicate one argument being passed push ax ; and save "operands" mov ax, [frameptr] ; save current stack frame pointer add ax, [base] push ax mov ax, [topofstack] ; update frameptr to where it will be add ax, SIZE POINTER ; after the new stack frame is built mov [frameptr], ax call stk_ovfl C ; signal stack overflow to create ; continuation data object mov bx, [prev_reg.page] ; load pointer to continuation mov di, [prev_reg.disp] ldpage es, bx mov al, [cb_reg.bpage] mov dx, [cb_reg.disp] mov [(CONTDEF es:di).codeblk.page], al mov [(CONTDEF es:di).codeblk.disp], dx sub si, dx mov [(CONTDEF es:di).retaddr.val], si add si, dx pop ax ; define dynamic link in continuation mov [(CONTDEF es:di).dynlink.val], ax sub ax, [base] ; put frameptr back to where it should be mov [frameptr], ax ; Note: frameptr's now negative (topofstack is 0) mov al, [prev_reg.bpage] ; Perform the Call-Closure-Tail-Recursive mov dx, [prev_reg.disp] mov [tm2_reg.bpage], al mov [tm2_reg.disp], dx pop ax ; recover "operands" to call-closure call call_closure mov al, [tm2_reg.bpage] mov dx, [tm2_reg.disp] mov [reg1.bpage], al mov [reg1.disp], dx jmp next_pc ENDP clcc_c ;************************************************************************ ;* al * ;* Call/cc with of procedure object CALL/CC-CLOSURE-TR ftn * ;* * ;* Purpose: Interpreter support for a tail recursive call with current * ;* continuation of a fully closed function * ;* * ;* Description: * ;* 1. The CALL/CC-CLOSURE argument is fetched. * ;* 2. The current continuation is formed using the * ;* caller's return address (since there's no way to * ;* return here from the tail recursive call). * ;* The pointer to the continuation is placed into * ;* VM register 1. * ;* 3. The CALL-CLOSURE-TR code is called to complete the * ;* call sequence. * ;************************************************************************ PROC clcc_ctr get1op mov ah, 1 ; indicate one argument being passed push ax ; and save "operands" call stk_ovfl C ; signal stack overflow to create ; continuation data object mov bx, [prev_reg.page] ; load pointer to continuation mov di, [prev_reg.disp] ldpage es, bx mov si, [frameptr] ; create a pointer to the current stack add si, OFFSET s_stack ; frame (the new one) mov al, [(STKFDEF si).codeblk.page] mov dx, [(STKFDEF si).codeblk.disp] mov [(CONTDEF es:di).codeblk.page], al mov [(CONTDEF es:di).codeblk.disp], dx mov ax, [(STKFDEF si).retaddr.disp] mov [(CONTDEF es:di).retaddr.val], ax mov ax, [(STKFDEF si).dynlink.disp] mov [(CONTDEF es:di).dynlink.val], ax mov al, [prev_reg.bpage] ; Perform the Call-Closure-Tail-Recursive mov dx, [prev_reg.disp] mov [tm2_reg.bpage], al mov [tm2_reg.disp], dx pop ax ; recover "operands" to call-closure-tr call call_closed_tr mov al, [tm2_reg.bpage] mov dx, [tm2_reg.disp] mov [reg1.bpage], al mov [reg1.disp], dx jmp next_pc ENDP clcc_ctr ;************************************************************************ ;* al ah * ;* Apply closure APPLY-CLOSURE ftn, args * ;* * ;* Purpose: Interpreter support for the "apply" primitive. The * ;* argument list (in register "args") are to be passed * ;* to the closure pointed to by the "ftn" register. * ;* * ;* Note: The argument registers may be anything that the compiler* ;* decides on, so the "ftn" pointer could be destroyed * ;* in the process of loading the arguments of the argument * ;* list ("args") into the VM general registers R1-Rn. * ;* So that the ftn pointer is not lost during this process, * ;* this pointer is pushed onto the 8088 stack before the * ;* call to process the arguments, and it is restored into * ;* the last available register to complete the call * ;* sequence. * ;* * ;* Garbage collection will not occur during the argument loading * ;* process (arguments are copied, but no cons-ing occurs), * ;* so it's safe to save the "ftn" pointer on the 8088 * ;* stack temporarily. * ;************************************************************************ last_reg EQU (regs + (NUM_REGS - 1) * SIZE REG) PROC apply get2op mov bl, al ; copy closure pointer register number push [regs+bx.page] ; save value of register containing push [regs+bx.disp] ; the closure pointer save <si> call aply_arg ; expand arguments into R1-Rn restore <si> pop [last_reg.disp] pop [last_reg.page] mov ah, cl ; copy the argument count to ah, al<="Rlast" mov al, last_reg - regs call call_closure jmp next_pc ENDP apply ;************************************************************************ ;* al ah * ;* Apply closure, tail recursively APPLY-CLOSURE-TR ftn, args * ;* * ;* Purpose: Interpreter support for the "apply" primitive. The * ;* argument list (in register "args") are to be passed * ;* to the closure pointed to by the "ftn" register. * ;* * ;* Note: See notes in "APPLY-CLOSURE" support, above. * ;************************************************************************ PROC apply_tr get2op mov bl, al ; copy closure pointer register number push [regs+bx.page] ; save value of register containing push [regs+bx.disp] ; the closure pointer save <si> call aply_arg ; expand arguments into R1-Rn restore <si> pop [last_reg.disp] pop [last_reg.page] mov ah, cl ; copy the argument count to ah, al<="Rlast" mov al, last_reg - regs call call_closed_tr jmp next_pc ENDP apply_tr ;************************************************************************ ;* Execute code block EXECUTE CODE * ;* * ;* Purpose: Interpreter support for the "execute" primitive operation. * ;* * ;* Description: The execute primitive causes a code block to be * ;* executed in a new environment. This is accomplished * ;* by executing a procedure call to the code block with * ;* no static environment information available. The * ;* new stack frame has a nil heap environment pointer, and * ;* the static link is set to point to itself to prevent * ;* access to any higher lexical levels. When the code * ;* block exits, control will return to the place where the * ;* execute instruction was executed. * ;************************************************************************ PROC execute get1op mov bx, ax @@retry: mov di, [regs+bx.page] cmp [ptype+di], CODETYPE je @@simplecode cmp [ptype+di], I86TYPE je @@simpleinline jmp @@load @@simpleinline: save <si> mov si, [regs+bx.disp] ; get entry point add si, OFFSET (TYPE I86DEF).data ldpage bx, di push bp push cs lea ax, [cs:@@inlineret] push ax push bx si lea si, [regs] ; pass on some information lea di, [@@disptable] retf ; call code @@inlineret: pop bp jmp next_pc DATASEG LABEL @@disptable DWORD DD $$loadpage ; provide access to most useful routines DD alloc_big_block DD alloc_block DD alloc_flonum DD alloc_int DD alloc_list_cell DD alloc_string DD cons DD free DD GETCH DD get_max_cols DD get_max_rows DD int2long DD is_graph_mode DD long2int DD malloc DD nosound DD sound DD zcuroff DD zcuron DD zprintf DD zputc DD zscroll DD zscroll_d CODESEG PROC C $$loadpage FAR @@page:WORD ; provide a far linkage to the code ldpage ax, [regs+62*(SIZE REGS).page] ; refresh the current block ldpage ax, [@@page] ret ENDP $$loadpage @@simplecode: push bx call new_sf ; create a new stack frame for the "call" mov [s_stack+bx.statlink.disp], 0 mov al, [gnv_reg.bpage] ; default environment to global env mov dx, [gnv_reg.disp] mov [s_stack+bx.heap.page], al mov [s_stack+bx.heap.disp], dx mov [frameptr], bx pop bx ; retrieve the code pointer's reg number mov si, [regs+bx.disp] ; define the code base register mov bl, [regs+bx.bpage] mov [cb_reg.disp], si mov [cb_reg.bpage], bl xor bh, bh ldpage es, bx add si, [(CODEDEF es:si).entry.val] ; adjust location ptr for entry OFFSET jmp next ; Object to be executed is not a code block, so we've got to create ; one for a compiled program before executing it. The format of an ; object program is: ; ; (PCS-CODE-BLOCK #-constants #-codebytes (constant ...) (codebyte ...)) ; or: ; (PCS-INLINE-BLOCK #-asmbytes (asmbyte ...)) ; @@load: save <bx, si> ; save dest register, location pointer cmp [ptype+di], LISTTYPE jne @@badheader ldpage es, di mov si, [regs+bx.disp] mov bl, [(LISTDEF es:si).car.page] mov si, [(LISTDEF es:si).car.disp] cmp [ptype+bx], SYMBTYPE jne @@badheader ldpage es, bx mov cl, [(SYMDEF es:si+4).buffer] ; get 5th char ldpage es, di restore <bx> mov si, [regs+bx.disp] mov bl, [(LISTDEF es:si).cdr.page] mov si, [(LISTDEF es:si).cdr.disp] cmp [ptype+bx], LISTTYPE jne @@badheader ldpage es, bx cmp [(LISTDEF es:si).car.page], SPECFIX*2 je @@firstfixok @@badheader: lea ax, [@@msg] DATASEG @@msg DB "%EXECUTE", 0 CODESEG restore <bx> ; load number of register containing add bx, OFFSET regs ; the "code" pointer and compute its addr mov cx, 1 ; load argument count = 1 push es ; save es over C call call set_src_error C, ax, cx, bx pop es restore <si> jmp sch_err @@firstfixok: mov ax, [(LISTDEF es:si).car.disp] cmp cl, 'I' ; was it 'PCS-C... or 'PCS-I ? jne @@codeblock jmp @@inline @@codeblock: inc ax ; add a constant for entry point address mov dx, ax ; dx <- ax * 3 shl ax, 1 add dx, ax mov bl, [(LISTDEF es:si).cdr.page] mov si, [(LISTDEF es:si).cdr.disp] cmp [ptype+bx], LISTTYPE jne @@badheader ldpage es, bx cmp [(LISTDEF es:si).car.page], SPECFIX*2 jne @@badheader mov ax, [(LISTDEF es:si).car.disp] add ax, dx ; add constants*3 + codebytes mov bx, CODETYPE push dx ; save the entry point call alloc_block C, [tmp_adr], bx, ax mov di, [tmp_reg.page] ldpage es, di mov dx, di ; save code block's page number in dx mov di, [tmp_reg.disp] add di, SIZE POINTER ; advance di past block header mov al, SPECFIX*2 ; store tag=fixnum for entry point address stosb pop ax ; store entry point address add ax, SIZE POINTER ; adjust entry point for block header stosw ; reload pointer to object program [Note: garbage collection may have ; copied the linked list representation of the program, so pointers ; held in TIPC registers may not be valid.] restore <bx> mov si, [regs+bx.page] ; load pointer to "object program" ldpage es, si mov si, [regs+bx.disp] mov bl, [(LISTDEF es:si).cdr.page] mov si, [(LISTDEF es:si).cdr.disp] ldpage es, bx mov cx, [(LISTDEF es:si).car.disp] mov bl, [(LISTDEF es:si).cdr.page] mov si, [(LISTDEF es:si).cdr.disp] ldpage es, bx mov ax, [(LISTDEF es:si).car.disp] mov bl, [(LISTDEF es:si).cdr.page] mov si, [(LISTDEF es:si).cdr.disp] cmp [ptype+bx], LISTTYPE jne @@tobadheader ldpage es, bx ; warning: ds is not the data segment push ax bx si ds ; save # codebytes ptr to const's list cell mov bl, [(LISTDEF es:si).car.page] ; load constant list header mov si, [(LISTDEF es:si).car.disp] ldpage es, dx jcxz @@constantsdone @@constantsloop: cmp bl, 0 ; end of constants list? jne @@moreconstants @@badconstants: pop ds add sp, 6 ; trash off @@tobadheader: jmp @@badheader @@moreconstants: cmp [ss:ptype+bx], LISTTYPE jne @@badconstants ldpage ds, bx movsb ; copy car field to code block constants movsw mov bl, [(POINTER si).page]; load the cdr mov si, [(POINTER si).disp] loop @@constantsloop @@constantsdone: mov ax, bx ; save the current list page pop ds si bx cx ; end of critical section ldpage es, bx mov bx, ax ; restore the list page in [bl:si] cmp bl, 0 ; end of list found? jne @@tobadheader mov bl, [(LISTDEF es:si).cdr.page] ; fetch pointer to code bytes mov si, [(LISTDEF es:si).cdr.disp] cmp [ptype+bx], LISTTYPE jne @@tobadheader ldpage es, bx cmp [(LISTDEF es:si).cdr.page], 0 ; last entry in object program list? jne @@tobadheader mov bl, [(LISTDEF es:si).car.page] ; load header to bytecode list mov si, [(LISTDEF es:si).car.disp] ldpage es, dx push ds ; warning: ds is not the data segment @@dataloop: cmp bl, 0 ; end of constants list? je @@badbytes cmp [ss:ptype+bx], LISTTYPE jne @@badbytes ldpage ds, bx lodsb ; load car's page number cmp al, SPECFIX*2 je @@itsadatabyte @@badbytes: pop ds jmp @@badheader @@itsadatabyte: lodsw ; load immediate value stosb ; store low order BYTE into code block mov bl, [(POINTER si).page]; get the cdr mov si, [(POINTER si).disp] loop @@dataloop cmp bl, 0 ; extraneous code bytes in list? jne @@badbytes pop ds ; end of critical section restore <bx, si> ; re-fetch dest reg, location pointer mov ax, [tmp_reg.page] mov dx, [tmp_reg.disp] mov [regs+bx.page], ax mov [regs+bx.disp], dx jmp @@retry @@inline: push ax mov bx, I86TYPE call alloc_block C, [tmp_adr], bx, ax mov bx, [tmp_reg.page] mov di, [tmp_reg.disp] ldpage es, bx add di, OFFSET (TYPE I86DEF).data pop cx restore <bx> mov si, [regs+bx.disp] mov bx, [regs+bx.page] push ds ; warning: ds is not the data segment ldpage ds, bx mov bl, [(LISTDEF si).cdr.page] mov si, [(LISTDEF si).cdr.disp] ldpage ds, bx mov bl, [(LISTDEF si).cdr.page] mov si, [(LISTDEF si).cdr.disp] cmp [ss:ptype+bx], LISTTYPE jne @@badinline mov bl, [(LISTDEF si).car.page] mov si, [(LISTDEF si).car.disp] @@inlineloop: cmp [ss:ptype+bx], LISTTYPE je @@inlineok @@badinline: pop ds jmp @@badheader @@inlineok: ldpage ds, bx cmp [(LISTDEF si).car.page], SPECFIX*2 jne @@badinline mov ax, [(LISTDEF si).car.disp] stosb mov bl, [(LISTDEF si).cdr.page] mov si, [(LISTDEF si).cdr.disp] loop @@inlineloop cmp bl, 0 jne @@badinline pop ds ; end of bad-ds section restore <bx, si> mov ax, [tmp_reg.page] mov dx, [tmp_reg.disp] mov [regs+bx.page], ax mov [regs+bx.disp], dx jmp @@retry ENDP execute ;************************************************************************ ;* Exit from current procedure EXIT * ;* * ;* Description: The internal registers of the VM are reset from * ;* information stored in the current frame pointer to * ;* restore the environment at the point where the current * ;* procedure was called (i.e., control returns to the * ;* calling routine). * ;************************************************************************ PROC s_exit mov ax, [frameptr] mov bx, ax add bx, OFFSET s_stack ; compute address of current stack frame sub ax, SIZE POINTER ; reset the current topofstack to previous mov [topofstack], ax ; value [frameptr - sizeof(pointer)] xor ax, ax mov al, [(STKFDEF bx).codeblk.page] ; load CB's page number mov dx, [(STKFDEF bx).codeblk.disp] ; update the current code base (CB) mov [cb_reg.bpage], al mov [cb_reg.disp], dx add dx, [(STKFDEF bx).retaddr.disp] ; load return address' location pointer mov si, dx ; and add in starting OFFSET of code block mov ax, [(STKFDEF bx).dynlink.disp] ; compute pointer to caller's stack frame mov bx, ax ; get a copy of it sub ax, [base] ; frameptr <- dynamic link - base cmp ax, STKSIZE ; is new frameptr outside stack buffer? jb @@inbounds push bx es call stk_unfl C ; process stack underflow pop es ax sub ax, [base] ; but this base is now OK @@inbounds: mov [frameptr], ax mov bx, [cb_reg.page] ldpage es, bx jmp next ENDP s_exit ;************************************************************************ ;* al al ah * ;* Create Closure CR-CLOSE dest, label, nargs * ;* * ;* Purpose: Scheme interpreter support for the creation of closure * ;* objects. * ;************************************************************************ PROC cr_close get1op mov di, ax get2op mov cx, ax get1op cbw add cx, si ; add in current location pointer sub cx, [cb_reg.disp] ; and adjust for code block OFFSET save <si> push ax cx di mov dx, CLOSTYPE mov ax, SIZE CLOSDEF-SIZE POINTER call alloc_block C, [tmp_adr], dx, ax mov bx, [tmp_reg.page] ; load pointer to closure object mov di, [tmp_reg.disp] ldpage es, bx pop si ; copy contents of destination register mov ax, di ; Make the destination register point xchg bl, [regs+si.bpage] ; to the closure object xchg ax, [regs+si.disp] mov [(CLOSDEF es:di).info.page], bl mov [(CLOSDEF es:di).info.disp], ax mov al, SPECFIX*2 mov [(CLOSDEF es:di).entry.tag], al pop [(CLOSDEF es:di).entry.val] mov [(CLOSDEF es:di).args.tag], al pop [(CLOSDEF es:di).args.val] mov al, [cb_reg.bpage] ; copy in pointer to current code base mov dx, [cb_reg.disp] mov [(CLOSDEF es:di).codeblk.page], al mov [(CLOSDEF es:di).codeblk.disp], dx mov si, [frameptr] mov al, [s_stack+si.heap.page] ; define heap environment mov dx, [s_stack+si.heap.disp] mov [(CLOSDEF es:di).heap.page], al mov [(CLOSDEF es:di).heap.disp], dx jmp next_pc ENDP cr_close ;************************************************************************ ;* Local support - stack overflow handler * ;* * ;* Purpose: To move part of Scheme's runtime stack to the heap when * ;* stack overflow occurs. * ;* * ;* Description: The contents of the stack which precede the current * ;* stack frame are moved to the heap (in a continuation * ;* object) and the current stack frame is moved to the * ;* top of the stack buffer. * ;* * ;* Input Parameters: * ;* TIPC register si - the value to be placed in the * ;* "return address displacement" field of the * ;* continuation (needed only for call/cc) * ;* FNV_reg - the current fluid environment (saved by * ;* call/cc) * ;* GNV_reg - the current global environment (saved by * ;* call/cc) * ;* frameptr - the current stack frame pointer * ;* base - the stack buffer base value * ;* topofstack - the current top-of-stack pointer * ;* CB - the VM register which points to the current * ;* code block * ;* PREV_page,PREV_disp - the VM's previous stack segment * ;* register * ;* * ;* Output Parameters: * ;* PREV_page,PREV_disp - a pointer to the continuation * ;* object which was created * ;* base - updated to the new base value (stack OFFSET) * ;* due to movement of some of the stack contents * ;* to the heap * ;* * ;* Variables Modified: (but logically unchanged) * ;* frameptr - the current stack frame pointer * ;* topofstack - the current top of stack pointer * ;* * ;* Example: Stack Overflow Condition * ;* * ;* Before * ;* * ;* +--------+----------------------+ * ;* | prev stk seg -> = nil | * ;* +--------+----------------------+ * ;* Stack Buffer (base = 0) * ;* +--------+----------------------+ * ;* | Contents | * ;* : of : * ;* : Stack : * ;* | (m BYTEs) | * ;* |--------+----------------------| * ;* | Current |<-frameptr * ;* : Stack : * ;* | Frame |<-topofstack * ;* +--------+----------------------+ * ;* * ;* AFTER * ;* * ;* "Continuation" in Heap * ;* +--------+-------------------+ +-------+------------------+ * ;* | prev stk seg -> |------>| cont | length (m+24) | * ;* +--------+-------------------+ |-------+------------------| * ;* Stack Buffer (base = m) | segment's stack base = 0 | * ;* +--------+-------------------+ |--------+-----------------| * ;* | Current |<-frameptr| code base -> = n/a | * ;* : Stack : |--------+-----------------| * ;* | Frame |<-topofstack|return addr disp = na| * ;* |--------+-------------------| |--------+-----------------| * ;* | unused stack | | caller dynamic link = n/a| * ;* : : |--------+-----------------| * ;* : : | fluid env -> = FNV_reg | * ;* | | |--------------------------| * ;* +--------+-------------------+ | prev stk seg -> = nil | * ;* |--------+-------------------| * ;* | global env -> = GNV_reg | * ;* |--------+-------------------| * ;* | Contents | * ;* : of : * ;* : Stack : * ;* | (m BYTEs) | * ;* +--------+-------------------+ * ;* * ;* Notes: This routine handles both routine stack overflow, and stack * ;* overflow which is signaled during the creation of a * ;* full continuation because of a call/cc. All of the * ;* fields of the continuation object are filled in by this * ;* routine, but they are meaningless and will never be * ;* used in the case of simple stack overflow. * ;************************************************************************ PROC C stk_ovfl FAR USES si di LOCAL @@si:WORD, @@reg:REG mov [@@si], si ; saves caller si for continuation mov cx, [frameptr] ; load current frame pointer, cmp cx, 0 ; length of stack contents zero? jg @@newcontinuation mov ax, [prev_reg.page] ; copy previous continuation mov dx, [prev_reg.disp] mov [tmp_reg.page], ax mov [tmp_reg.disp], dx lea ax, [prev_reg] ; load address of PREV_reg, tmp_reg call copy_blk C, ax, [tmp_adr] jmp @@ret @@newcontinuation: add cx, OFFSET (TYPE CONTDEF).data-SIZE POINTER mov dx, CONTTYPE ; load tag=CONTTYPE lea bx, [@@reg] ; load address of temporary result reg call alloc_block C, bx, dx, cx mov cx, [frameptr] ; reload length of continuations stack data mov bx, [@@reg.page] ; load returned pointer to mov di, [@@reg.disp] ; continuation object ldpage es, bx mov al, SPECFIX*2 mov [(CONTDEF es:di).base.tag], al mov [(CONTDEF es:di).retaddr.tag], al mov [(CONTDEF es:di).dynlink.tag], al mov al, [cb_reg.bpage] ; define code base pointer mov dx, [cb_reg.disp] mov [(CONTDEF es:di).codeblk.page], al mov [(CONTDEF es:di).codeblk.disp], dx neg dx ; subtract CB_disp from si add dx, [@@si] ; use contents of si for return addr disp mov [(CONTDEF es:di).retaddr.val], dx mov ax, [frameptr] ; define dynamic link mov [(CONTDEF es:di).dynlink.val], ax mov ax, [base] ; set continuation's stack base mov [(CONTDEF es:di).base.val], ax add ax, cx ; compute new stack buffer base mov [base], ax ; base <- base + frameptr mov al, [fnv_reg.bpage] ; set fluid environment pointer mov dx, [fnv_reg.disp] mov [(CONTDEF es:di).fluid.page], al mov [(CONTDEF es:di).fluid.disp], dx mov al, [gnv_reg.bpage] ; set global environment pointer mov dx, [gnv_reg.disp] mov [(CONTDEF es:di).globenv.page], al mov [(CONTDEF es:di).globenv.disp], dx mov ax, [prev_reg.page] ; set previous stack segment pointer mov dx, [prev_reg.disp] mov [(CONTDEF es:di).stk.page], al mov [(CONTDEF es:di).stk.disp], dx mov [prev_reg.page], bx ; make previous stack segment register mov [prev_reg.disp], di ; point to the new continuation object add [WORD LOW stk_out], cx ; record number of BYTEs transfered adc [WORD HIGH stk_out], 0 lea si, [s_stack] ; move stack data to continuation object in the heap add di, OFFSET (TYPE CONTDEF).data ; adjust for continuation header info shr cx, 1 ; convert BYTEs to WORDs rep movsw adc cx, 0 ; if cx was odd, put 1 in cx rep movsb ; copy remaining BYTE, if needed lea si, [s_stack] ; move data in current stack frame to top of stack buffer mov di, si ; di <- top of stack buffer (0) add si, [frameptr] ; si <- current stack frame push ds pop es mov cx, [topofstack] ; load current top of stack, sub cx, [frameptr] ; subtract BYTEs moved to heap, mov [topofstack], cx add cx, SIZE POINTER ; compute BYTEs of stack to move up shr cx, 1 ; convert BYTEs to WORDs rep movsw adc cx, 0 rep movsb ; copy remaining BYTE, if needed mov [frameptr], 0 ; current frame now at top of stack buffer @@ret: ret ENDP stk_ovfl ;************************************************************************ ;* Local support - stack underflow handler * ;* * ;* Purpose: To restore segments of the stack, which previously have * ;* been moved to the heap, back into the stack buffer. * ;* * ;* Description: Previously saved stack segments (moved to the heap * ;* as the result of a stack overflow or a call/cc) are * ;* represented as continuation data objects. When this * ;* routine is called, a "stack underflow" has occurred * ;* as an "EXIT" operation needs to access a stack frame * ;* higher in the stack, so data fields with a call/cc * ;* continuation are ignored. * ;************************************************************************ PROC C stk_unfl USES si di ds mov bx, [prev_reg.page] mov si, [prev_reg.disp] or bx, bx ; stack link nil? jz @@underflow push ds pop es ldpage ds, bx mov ax, [(CONTDEF si).base.val] ; update stack buffer's base mov [es:base], ax mov al, [(CONTDEF si).stk.page] ; update previous stack segment register mov dx, [(CONTDEF si).stk.disp] mov [es:prev_reg.bpage], al mov [es:prev_reg.disp], dx mov cx, [(CONTDEF si).len] sub cx, OFFSET (TYPE CONTDEF).data ; adjust length for continuation header add si, OFFSET (TYPE CONTDEF).data ; adjust OFFSET for continuation header lea di, [s_stack] mov dx, cx ; compute new top of stack sub dx, SIZE POINTER mov [es:topofstack], dx add [WORD LOW es:stk_in], cx; update count of BYTEs transfered adc [WORD HIGH es:stk_in], 0 shr cx, 1 cld rep movsw adc cx, 1 rep movsb ret @@underflow: lea bx, [@@msg] DATASEG @@msg DB "[VM INTERNAL ERROR] Stack underflow", LF, 0 CODESEG call zprintf C, bx call force_reset C ENDP stk_unfl ;************************************************************************ ;* Local support - Create new stack frame * ;* * ;* Purpose: To create and partially define a new stack frame prior * ;* to a procedure call * ;* * ;* Description: This routine allocates space on the top of the stack * ;* for a new stack frame and defines the following fields: * ;* * ;* code base pointer <- CB * ;* return addr disp <- si (contents of reg) * ;* dynamic link <- frameptr * ;* static link's tag <- fixnum * ;* heap env <- current heap env * ;* static link <- current static link * ;* closure pointer <- nil (implies an open call) * ;* * ;* Input Parameters: * ;* TIPC register si - the VM's location pointer * ;* CB_page,CB_disp - the VM's code base register * ;* frameptr - the VM's current frame pointer * ;* topofstack - the VM's top of stack pointer * ;* * ;* Output Parameters: * ;* TIPC register bx - pointer to new stack frame * ;* (displacement in stack) * ;* topofstack - top of stack pointer updated for new stack length * ;* * ;* Variables Modified: The following variables will be modified if * ;* a stack overflow occurs during the push operation for * ;* the new stack frame: * ;* * ;* frameptr - the VM's current frame pointer(logically unchanged) * ;* base - the VM's stack buffer base * ;* PREV_page,PREV_disp - the VM's previous stack segment reg * ;************************************************************************ PROC new_sf NEAR @@retry: mov ax, [topofstack] ; load current top of stack pointer mov bx, ax ; and make a copy add ax, SIZE STKFDEF cmp ax, STKSIZE-SIZE POINTER jg @@overflow mov [topofstack], ax ; update top of stack pointer add bx, SIZE POINTER ; compute pointer to new stack frame mov al, SPECFIX*2 mov [s_stack+bx.retaddr.page], al mov [s_stack+bx.dynlink.page], al mov [s_stack+bx.statlink.page], al xor ax, ax mov [s_stack+bx.closure.page], al mov [s_stack+bx.closure.disp], ax mov al, [cb_reg.bpage] ; move current code base pointer mov dx, [cb_reg.disp] mov [s_stack+bx.codeblk.page], al ; into the new stack frame mov [s_stack+bx.codeblk.disp], dx sub si, dx ; compute ret addr relative to code block mov [s_stack+bx.retaddr.disp], si add si, dx mov di, [frameptr] ; load the current stack frame pointer mov al, [s_stack+di.heap.page] mov dx, [s_stack+di.heap.disp] mov [s_stack+bx.heap.page], al mov [s_stack+bx.heap.disp], dx mov ax, [s_stack+di.statlink.disp] mov [s_stack+bx.statlink.disp], ax add di, [base] mov [s_stack+bx.dynlink.disp], di ret @@overflow: push es ; save es over C call call stk_ovfl C ; process the overflow pop es jmp @@retry ENDP new_sf ;************************************************************************ ;* Local support - drop items from the heap environment * ;* * ;* Purpose: To drop "n" items off the local heap environment * ;* * ;* Input Parameters: * ;* TIPC register cx - the number of items to drop * ;* frameptr - the current stack frame pointer * ;* * ;* Output Parameters: * ;* TIPC register bx - page number for the remaining * ;* heap environment list * ;* TIPC register di - displacement pointer for the * ;* remaining heap environment * ;* * ;* Registers/Variables Modified: * ;* cx - decremented to zero * ;* TIPC register es - contents undefined * ;************************************************************************ PROC delta_hp NEAR mov di, [frameptr] xor bx, bx mov bl, [s_stack+di.heap.page] mov di, [s_stack+di.heap.disp] or cx, cx ; drop zero elements? jle @@ret @@loop: ldpage es, bx mov bl, [(LISTDEF es:di).cdr.page] ; load link pointer (cdr field) mov di, [(LISTDEF es:di).cdr.disp] loop @@loop @@ret: ret ENDP delta_hp ;************************************************************************ ;* Local support - Obtain Frame Pointer for given lexical level * ;* * ;* Input Parameters: * ;* TIPC register cx - desired lexical level number * ;* 0=current lexical level, * ;* 1=lexical parent's level, etc. * ;* frameptr - current frame pointer * ;* base - current stack buffer base * ;* * ;* Output Parameters: * ;* TIPC register bx - frame pointer for desired level * ;* (absolute location in stack) * ;* es:[si] - pointer to desired stack frame * ;* (either in stack buffer, or in the heap) * ;* * ;* Notes: Register usage: * ;* ax - zeroed, so page numbers can be loaded into al * ;* prior to copying to di * ;* bx - frame pointer for current level * ;* cx - lexical level counter. decremented at each level * ;* dx - base OFFSET of the stack segment currently being * ;* examined * ;* si - stack segment's (continuation's) displacement * ;* di - temporarily hold page number of next stack segment * ;************************************************************************ PROC delta_lv NEAR mov bx, [frameptr] mov dx, [base] or cx, cx jg @@nothere lea si, [s_stack+bx] ; compute addr of current frame pointer add bx, dx ; adjust for base of stack buffer push ds pop es ret ; return bx, [es:si] to caller @@loop: sub bx, dx ; adjust absolute frame ptr by base jb @@searchhigher @@nothere: mov bx, [s_stack+bx.statlink.disp] loop @@loop ; iterate until desired level found mov si, bx ; copy absolute frame pointer sub si, dx ; adjust for current stack buffer base jb @@outofstack add si, OFFSET s_stack ; compute address of frame in stack buffer push ds pop es ret ; return bx, [es:si] @@outofstack: mov di, [prev_reg.page] ; load pointer to previous stack segment mov si, [prev_reg.disp] ldpage es, di mov dx, [(CONTDEF es:si).base.val] xor ax, ax @@nextone: cmp bx, dx ; is frame within this segment? jae @@here mov al, [(CONTDEF es:si).stk.page] ; load pointer to its previous segment mov di, ax mov si, [(CONTDEF es:si).stk.disp] ldpage es, di mov dx, [(CONTDEF es:si).base.val] ; load stack segment's base OFFSET jmp @@nextone @@here: mov ax, bx ; copy absolute frame pointer for level sub ax, dx ; subtract this stack segment's base add si, ax ; add to continuation OFFSET add si, OFFSET (TYPE CONTDEF).data ; add fudge factor for continuation header ret ; return bx, es:[si] to caller @@searchhigher: add bx, dx ; compute absolute location in stack mov di, [prev_reg.page] ; load previous stack segment pointer mov si, [prev_reg.disp] ldpage es, di mov dx, [(CONTDEF es:si).base.val] xor ax, ax @@searchnext: cmp bx, dx ; is frame in this stack segment? jae @@found mov al, [(CONTDEF es:si).stk.page]; fetch pointer to next previous segment mov di, ax mov si, [(CONTDEF es:si).stk.disp] ldpage es, di mov dx, [(CONTDEF es:si).base.val] ; load this segment's base OFFSET jmp @@searchnext @@found: sub bx, dx ; adjust frame displacement for seg base mov bx, [(STKFDEF (CONTDEF es:si+bx).data).statlink.disp] ; load static link loop @@searchnext jmp @@nextone ENDP delta_lv ;************************************************************************ ;* Local support - Expand "apply's" argument list into registers R1-Rn * ;* * ;* Purpose: To expand the argument list of an "apply" so that the * ;* operands are in the proper operand registers (R1-Rn) * ;* for a call to a closed procedure. * ;* * ;* Input Parameters: TIPC register ah - the number of the VM's * ;* general register which contains the pointer to * ;* the linked list of arguments. * ;* * ;* Output Parameters: TIPC register cx - a count of the arguments. * ;* * ;* Note: The "apply" operation expects two operands which are a * ;* function and a 'list' of arguments. In the event that * ;* the second argument is not a list, this routine simply * ;* substitutes that value as if it were an argument. This * ;* means that the "LIST" function is not actually needed * ;* for an argument list containing only one value. * ;* For example, the following are handled equivalently: * ;* * ;* "correct" code "not-correct" code * ;* (apply ftn (list 1)) (apply ftn 1) * ;* (apply ftn (list a b)) (apply ftn (cons a b)) * ;* * ;* Although this could be viewed as an optimization, in * ;* that it saves one list cell each time the argument list * ;* is created, the real reason it is done is to provide * ;* a fixup action when an error condition is detected. * ;************************************************************************ PROC aply_arg NEAR xor bx, bx ; copy the register number of the mov bl, ah ; argument list to bx mov si, [regs+bx.disp] ; load the argument list pointer mov bx, [regs+bx.page] lea di, [reg1] xor cx, cx ; count the arguments @@writeloop: cmp bl, 0 ; is pointer nil? je @@done inc cx cmp [ptype+bx], LISTTYPE ; pointer to a list cell? jne @@dottedlist cmp cx, NUM_REGS - 2 ; allow R1-R61 proper regs, R62 is the tail jae @@dottedlist ; we're out of registers, so condense up ldpage es, bx mov al, [(LISTDEF es:si).car.page] mov dx, [(LISTDEF es:si).car.disp] mov [(REG di).bpage], al mov [(REG di).disp], dx mov bl, [(LISTDEF es:si).cdr.page] mov si, [(LISTDEF es:si).cdr.disp] add di, SIZE REG ; increment next register's address jmp @@writeloop @@dottedlist: mov [(REG di).page], bx mov [(REG di).disp], si @@done: ret ENDP aply_arg ;************************************************************************ ;* Borland C callable routine to force a Scheme VM call * ;* Calling Sequence: force_call(ret) * ;* where: int ret - the return address (relative to the * ;* current code block) * ;************************************************************************ PROC C force_call FAR @@ret:WORD mov si, [@@ret] call new_sf ; create a new stack frame mov [frameptr], bx ret ENDP force_call END